home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Gold Medal Software 2
/
Gold Medal Software Volume 2 (Gold Medal) (1994).iso
/
print
/
wsfont.arj
/
FM.BAS
< prev
next >
Wrap
BASIC Source File
|
1993-10-04
|
8KB
|
240 lines
Option Explicit
Option Compare Text
Global MoveBasic%
Global TestFont$
Global CRLF$
Global ActiveC As ListBox
Type Logfont
lfHeight As Integer
lfWidth As Integer
lfEscapement As Integer
lfOrientation As Integer
lfWeight As Integer
lfItalic As String * 1
lfUnderline As String * 1
lfStrikeOut As String * 1
lfCharSet As String * 1
lfOutPrecision As String * 1
lfClipPrecision As String * 1
lfQuality As String * 1
lfPitchAndFamily As String * 1
lfFaceName As String * 32
End Type
Type TextMetric
tmHeight As Integer
tmAscent As Integer
tmDescent As Integer
tmInternalLeading As Integer
tmExternalLeading As Integer
tmAveCharWidth As Integer
tmMaxCharWidth As Integer
tmWeight As Integer
tmItalic As String * 1
tmUnderlined As String * 1
tmStruckOut As String * 1
tmFirstChar As String * 1
tmLastChar As String * 1
tmDefaultChar As String * 1
tmBreakChar As String * 1
tmPitchAndFamily As String * 1
tmCharSet As String * 1
tmOverhang As Integer
tmDigitizedAspectX As Integer
tmDigitizedAspectY As Integer
End Type
Global TM As TextMetric
Global lf As Logfont
Global LfArray(255) As Logfont
Global TMArray(255) As TextMetric
Global pFonts() As String
Declare Function EnumFonts% Lib "GDI" (ByVal hDC%, ByVal lpFaceName As Any, ByVal lpFontFUnc&, ByVal lpData&)
'Declare Function GetObject% Lib "GDI" (ByVal hObject%, ByVal nCount%, ByVal lpObject&)
'Declares for INI file routines
Declare Function WritePrivateProfileString% Lib "KERNEL" (ByVal lpApplicationName$, ByVal lpKeyName$, ByVal lpString As Any, ByVal lplFileName$)
Declare Function WriteProfileString% Lib "KERNEL" (ByVal lpApplicationName$, ByVal lpKeyName$, ByVal lpString As Any)
Declare Function GetProfileInt% Lib "KERNEL" (ByVal lpAppName$, ByVal lpKeyName$, ByVal nDefault%)
Declare Function GetPrivateProfileInt% Lib "KERNEL" (ByVal lpApplicationName$, ByVal lpKeyName$, ByVal nDefault%, ByVal lpFilename$)
Declare Function GetPrivateProfileString% Lib "KERNEL" (ByVal lpApplicationName$, ByVal lpKeyName As Any, ByVal lpDefault$, ByVal lpReturnedString$, ByVal nSize%, ByVal lpFilename$)
Declare Function GetProfileString% Lib "KERNEL" (ByVal lpAppName$, ByVal lpKeyName As Any, ByVal lpDefault$, ByVal lpReturnedString$, ByVal nSize%)
Declare Function AddFontResource% Lib "GDI" (ByVal lpFilename As Any)
Declare Function RemoveFontResource% Lib "GDI" (ByVal lpFilename As Any)
Declare Function SendMessage% Lib "USER" (ByVal hWnd%, ByVal wMsg%, ByVal wParam%, lParam As Any)
Const WM_FONTCHANGE = &H1D
Const WM_WININICHANGE = &H1A
'Declares for GetSystemDir
Declare Function GetSystemDirectory Lib "Kernel" (ByVal lpBuffer As String, ByVal nSize As Integer) As Integer
Sub BroadcastIniChange ()
Dim y%
y% = SendMessage(&H0, WM_FONTCHANGE, 0, 0)'tell other apps that font list has changed
y% = SendMessage(&H0, WM_WININICHANGE, 0, 0)'tell other apps that WIN.INI has changed
End Sub
Sub DeletePrivIni (pApp$, pkey$, pFile$)
Dim X%
X% = WritePrivateProfileString%(pApp$, pkey$, 0&, pFile$)
End Sub
Sub DeleteWinIni (pApp$, pkey$)
Dim X%
X% = WriteProfileString%(pApp$, pkey$, 0&)
End Sub
Function Exists% (F$)
' * * * * * * * * * * * * * * * * * * * * * * * * * * * *
' returns 0 if file not found, or if error in file spec,
' otherwise returns -1
' * * * * * * * * * * * * * * * * * * * * * * * * * * * *
On Error Resume Next
Exists% = True
If Len(Dir$(F$)) = 0 Then Exists% = False
On Error GoTo 0
End Function
Function GetPrivINI$ (pApp$, pkey$, pDefault$, pFile$)
Dim X%
Dim ret As String * 1024
X% = GetPrivateProfileString%(pApp$, pkey$, pDefault$, ret, Len(ret), pFile$)
If X% > 0 Then GetPrivINI$ = Left$(ret, X%)
End Function
Function GetPrivIniInt% (pApp$, pkey$, pDefault%, pFile$)
GetPrivIniInt% = GetPrivateProfileInt%(pApp$, pkey$, pDefault%, pFile$)
End Function
Function GetSystemDir$ ()
Dim Sys As String * 256, X%
X = GetSystemDirectory(Sys, Len(Sys))
'X = InStr(1, Sys, Chr$(0))
GetSystemDir$ = Left$(Sys, InStr(Sys, Chr$(0)) - 1) + "\"
End Function
Function GetWinINI$ (pApp$, pkey$, pDefault$)
Dim X%
Dim ret As String * 1024
X% = GetProfileString%(pApp$, pkey$, pDefault$, ret, Len(ret))
If X% > 0 Then GetWinINI$ = Left$(ret, X%)
End Function
Function GetWinIniInt% (pApp$, pkey$, pDefault%)
GetWinIniInt% = GetProfileInt%(pApp$, pkey$, pDefault%)
End Function
Function HIWORD% (LongVal&)
HIWORD% = LongVal& \ 65536 ' (note: '\', not '/')
End Function
Function Install% (fName$)
Dim ret As String * 255
Dim test$, y%
test$ = GetPrivINI$("fonts", fName$, "uh-oh", "WSFONTS.INI")
If test$ = "uh-oh" Then MsgBox "can't install " & fName$: Exit Function
y% = AddFontResource(test$) ' remove font resource for this file
If y% <> 0 Then
PutWinIni "fonts", fName$, test$
DeletePrivIni "fonts", fName$, "WSFONTS.INI"
Else
MsgBox "Couldn't install font."
End If
Install% = True
End Function
Function ListPrivateIniEntries$ (pApp$, pFile$)
Dim X%
Dim ret As String * 4096
X% = GetPrivateProfileString%(pApp$, 0&, "", ret, Len(ret), pFile$)
If X% > 0 Then ListPrivateIniEntries$ = Left$(ret, X%)
End Function
Function ListWinIniEntries$ (pApp$)
Dim X%
Dim ret As String * 4096
X% = GetProfileString%(pApp$, 0&, "", ret, Len(ret))
If X% > 0 Then ListWinIniEntries$ = Left$(ret, X%)
End Function
Function LoWord% (LongVal&)
LoWord% = LongVal& And 65535
End Function
Sub PutPrivIni (pApp$, pkey$, pString$, pFile$)
Dim X%
X% = WritePrivateProfileString%(pApp$, pkey$, pString$, pFile$)
End Sub
Sub PutWinIni (pApp$, pkey$, pString$)
Dim X%
X% = WriteProfileString%(pApp$, pkey$, pString$)
End Sub
Function ReadFontInfo$ (ByVal F$)
Dim fh%, A$, B$, lf%, X%, re%, test$
fh% = FreeFile
F$ = UCase$(F$)
If Not InStr(F$, "\") Then F$ = GetSystemDir$() & F$
If Not InStr(F$, "FOT") > 0 Then ReadFontInfo$ = F$: Exit Function
If Not Exists%(F$) Then MsgBox "Can't find" + F$
lf% = FileLen(F$)
' Debug.Print F$; lf%
Dim GetStuff As String * 5000
Open F$ For Input As fh%
On Error Resume Next
GetStuff = Input$(lf%, #fh%)
B$ = Left$(GetStuff, lf%)
On Error GoTo 0
Close fh%
If Len(B$) < 260 Then MsgBox "Can't read " & F$: Exit Function
B$ = Right$(B$, 260)
For X% = 1 To Len(B$)
test$ = Mid$(B$, X%, 1)
If Asc(test$) > 31 And Asc(test$) < 127 Then
A$ = A$ + Mid$(B$, X%, 1)
End If
If Asc(test$) = 0 Then A$ = A$ + "|"
Next
'trim v|'s
X% = InStr(A$, "v|")
Do While X%
A$ = Mid$(A$, X% + 2)
X% = InStr(A$, "v|")
Loop
'TRIM LEADERS
If X% > 0 Then A$ = Mid$(A$, X% + 2)
Do While Left$(A$, 1) = "|"
A$ = Mid$(A$, 2)
Loop
'trim trailers
Do While Right$(A$, 1) = "|"
A$ = Left$(A$, Len(A$) - 1)
Loop
'should now read
ReadFontInfo$ = A$
End Function
Function UninStall% (ByVal fName$)
Dim ret As String * 255
Dim test$, y%
test$ = GetWinINI$("fonts", fName$, "uh-oh")
If test$ = "uh-oh" Then MsgBox "Can't uninstall " & fName$: Exit Function
y% = RemoveFontResource(test$) ' remove font resource for this file
PutPrivIni "fonts", fName$, test$, "WSFONTS.INI"
DeleteWinIni "fonts", fName$
UninStall% = True
End Function
Function UnsignedInt& (AA$)
' * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
' Convert string to unsigned int
' * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
Dim Value&
Value& = Asc(Right$(AA$, 1)) * 256&
Value& = Value& + Asc(Left$(AA$, 1))
UnsignedInt& = Value&
End Function